home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / akcl / kcl.lha / cmpnew / cmploc.lsp < prev    next >
Lisp/Scheme  |  1987-06-03  |  9KB  |  245 lines
  1. ;;; CMPLOC  Set-loc and Wt-loc.
  2. ;;;
  3. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  4. ;; Copying of this file is authorized to users who have executed the true and
  5. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  6.  
  7. (in-package 'compiler)
  8.  
  9. (defvar *value-to-go*)
  10.  
  11. ;;; Valid locations are:
  12. ;;;    NIL
  13. ;;;    T
  14. ;;;    'FUN-VAL'
  15. ;;;    ( 'VS' vs-address )
  16. ;;;    ( 'VS*' vs-address )
  17. ;;;    ( 'CCB-VS' ccb-vs )
  18. ;;;    ( 'VAR' var-object ccb )
  19. ;;;    ( 'VV' vv-index )
  20. ;;;    ( 'CVAR' cvar )
  21. ;;;    ( 'INLINE' side-effect-p fun/string locs )
  22. ;;;    ( 'INLINE-COND' side-effect-p fun/string locs )
  23. ;;;    ( 'INLINE-FIXNUM' side-effect-p fun/string locs )
  24. ;;;    ( 'INLINE-CHARACTER' side-effect-p fun/string locs )
  25. ;;;    ( 'INLINE-LONG-FLOAT' side-effect-p fun/string locs )
  26. ;;;    ( 'INLINE-SHORT-FLOAT' side-effect-p fun/string locs )
  27. ;;;    ( 'SIMPLE-CALL {   SYMLISPCALL-NO-EVENT
  28. ;;;                        | LISPCALL-NO-EVENT
  29. ;;;                        | SYMLISPCALL
  30. ;;;                        | LISPCALL }
  31. ;;;        vs-index number-of-arguments [ vv-index ] )
  32. ;;;    ( 'VS-BASE' offset )
  33. ;;;    ( 'CAR' cvar )
  34. ;;;    ( 'CADR' cvar )
  35. ;;;    ( 'SYMBOL-FUNCTION' vv-index )
  36. ;;;    ( 'MAKE-CCLOSURE' cfun cllink )
  37. ;;;    ( 'FIXNUM-VALUE' vv-index fixnum-value )
  38. ;;;    ( 'FIXNUM-LOC' loc )
  39. ;;;    ( 'CHARACTER-VALUE' vv-index character-code )
  40. ;;;    ( 'CHARACTER-LOC' loc )
  41. ;;;    ( 'LONG-FLOAT-VALUE' vv-index long-float-value )
  42. ;;;    ( 'LONG-FLOAT-LOC' loc )
  43. ;;;    ( 'SHORT-FLOAT-VALUE' vv-index short-float-value )
  44. ;;;    ( 'SHORT-FLOAT-LOC' loc )
  45.  
  46.  
  47. ;;; Valid *value-to-go* locations are:
  48. ;;;
  49. ;;;    'RETURN'    The value is returned from the current function.
  50. ;;;    'RETURN-FIXNUM'
  51. ;;;    'RETURN-CHARACTER'
  52. ;;;    'RETURN-LONG-FLOAT'
  53. ;;;    'RETURN-SHORT-FLOAT'
  54. ;;;    'RETURN-OBJECT
  55. ;;;    'TRASH'        The value may be thrown away.
  56. ;;;    'TOP'        The value should be set at the top of vs as if it were
  57. ;;;            a resulted value of a function call.
  58. ;;;    ( 'VS' vs-address )
  59. ;;;    ( 'VS*' vs-address )
  60. ;;;    ( 'CCB-VS' ccb-vs )
  61. ;;;    ( 'VAR' var-object ccb )
  62. ;;;    ( 'JUMP-TRUE' label )
  63. ;;;    ( 'JUMP-FALSE' label )
  64. ;;;    ( 'BDS-BIND' vv-index )
  65. ;;;    ( 'PUSH-CATCH-FRAME' )
  66. ;;;    ( 'DBIND' symbol-name-vv )
  67.  
  68. (si:putprop 'cvar 'wt-cvar 'wt-loc)
  69. (si:putprop 'vv 'wt-vv 'wt-loc)
  70. (si:putprop 'car 'wt-car 'wt-loc)
  71. (si:putprop 'cdr 'wt-cdr 'wt-loc)
  72. (si:putprop 'cadr 'wt-cadr 'wt-loc)
  73. (si:putprop 'vs-base 'wt-vs-base 'wt-loc)
  74. (si:putprop 'fixnum-value 'wt-fixnum-value 'wt-loc)
  75. (si:putprop 'fixnum-loc 'wt-fixnum-loc 'wt-loc)
  76. (si:putprop 'character-value 'wt-character-value 'wt-loc)
  77. (si:putprop 'character-loc 'wt-character-loc 'wt-loc)
  78. (si:putprop 'long-float-value 'wt-long-float-value 'wt-loc)
  79. (si:putprop 'long-float-loc 'wt-long-float-loc 'wt-loc)
  80. (si:putprop 'short-float-value 'wt-short-float-value 'wt-loc)
  81. (si:putprop 'short-float-loc 'wt-short-float-loc 'wt-loc)
  82.  
  83. (defun set-loc (loc &aux fd)
  84.   (cond ((eq *value-to-go* 'return) (set-return loc))
  85.         ((eq *value-to-go* 'trash)
  86.          (cond ((and (consp loc)
  87.                      (member (car loc)
  88.                              '(INLINE INLINE-COND INLINE-FIXNUM
  89.                                INLINE-CHARACTER INLINE-LONG-FLOAT
  90.                                INLINE-SHORT-FLOAT))
  91.                      (cadr loc))
  92.                 (wt-nl "(void)(") (wt-inline t (caddr loc) (cadddr loc))
  93.                 (wt ");"))
  94.                ((and (consp loc) (eq (car loc) 'SIMPLE-CALL))
  95.                 (wt-nl "(void)" loc ";"))))
  96.         ((eq *value-to-go* 'top)
  97.          (unless (eq loc 'fun-val) (set-top loc)))
  98.         ((eq *value-to-go* 'return-fixnum) (set-return-fixnum loc))
  99.         ((eq *value-to-go* 'return-character) (set-return-character loc))
  100.         ((eq *value-to-go* 'return-long-float) (set-return-long-float loc))
  101.         ((eq *value-to-go* 'return-short-float) (set-return-short-float loc))
  102.         ((or (not (consp *value-to-go*))
  103.              (not (symbolp (car *value-to-go*))))
  104.          (baboon))
  105.         ((setq fd (get (car *value-to-go*) 'set-loc))
  106.          (apply fd loc (cdr *value-to-go*)))
  107.         ((setq fd (get (car *value-to-go*) 'wt-loc))
  108.          (wt-nl) (apply fd (cdr *value-to-go*)) (wt "= " loc ";"))
  109.         (t (baboon)))
  110.   )
  111.  
  112. (defun wt-loc (loc)
  113.   (cond ((eq loc nil) (wt "Cnil"))
  114.         ((eq loc t) (wt "Ct"))
  115.         ((eq loc 'fun-val) (wt "vs_base[0]"))
  116.         ((or (not (consp loc))
  117.              (not (symbolp (car loc))))
  118.          (baboon))
  119.         (t (let ((fd (get (car loc) 'wt-loc)))
  120.                 (when (null fd) (baboon))
  121.                 (apply fd (cdr loc)))))
  122.   )
  123.  
  124. (defun set-return (loc)
  125.   (cond ((eq loc 'fun-val))
  126.         ((and (consp loc) (eq (car loc) 'vs) (= (caadr loc) *level*))
  127.          (wt-nl "vs_top=(vs_base=base+" (cdadr loc) ")+1;")
  128.          (base-used))
  129.         ((and (consp loc)
  130.               (eq (car loc) 'var)
  131.               (eq (var-kind (cadr loc)) 'LEXICAL)
  132.               (not (var-ref-ccb (cadr loc)))
  133.               (= (car (var-ref (cadr loc))) *level*))
  134.          (wt-nl "vs_top=(vs_base=base+" (cdr (var-ref (cadr loc))) ")+1;")
  135.          (base-used))
  136.         (t (set-top loc)))
  137.   )
  138.  
  139. (defun set-top (loc)
  140.  (let ((*vs* *vs*))
  141.       (wt-nl) (wt-vs (vs-push)) (wt "= " loc ";")
  142.       (wt-nl "vs_top=(vs_base=base+" (1- *vs*) ")+1;")
  143.       (base-used)))
  144.  
  145. (defun wt-vs-base (offset) (wt "vs_base[" offset "]"))
  146.  
  147. (defun wt-car (cvar) (wt "(V" cvar "->c.c_car)"))
  148.  
  149. (defun wt-cdr (cvar) (wt "(V" cvar "->c.c_cdr)"))
  150.  
  151. (defun wt-cadr (cvar) (wt "(V" cvar "->c.c_cdr->c.c_car)"))
  152.  
  153. (defun wt-cvar (cvar) (wt "V" cvar))
  154.  
  155. (defun wt-vv (vv) (wt "VV[" vv "]"))
  156.  
  157. (defun wt-fixnum-loc (loc)
  158.   (cond ((and (consp loc)
  159.               (eq (car loc) 'var)
  160.               (eq (var-kind (cadr loc)) 'FIXNUM))
  161.          (wt "V" (var-loc (cadr loc))))
  162.         ((and (consp loc) (eq (car loc) 'INLINE-FIXNUM))
  163.          (wt-inline-loc (caddr loc) (cadddr loc)))
  164.         ((and (consp loc) (eq (car loc) 'fixnum-value))
  165.          (wt (caddr loc)))
  166.         (t (wt "fix(" loc ")"))))
  167.  
  168. (defun fixnum-loc-p (loc)
  169.   (and (consp loc)
  170.        (or (and (eq (car loc) 'var)
  171.                 (eq (var-kind (cadr loc)) 'FIXNUM))
  172.            (eq (car loc) 'INLINE-FIXNUM)
  173.            (eq (car loc) 'fixnum-value))))
  174.  
  175. (defun wt-fixnum-value (vv fixnum-value)
  176.        (declare (ignore fixnum-value))
  177.        (wt "VV[" vv "]"))
  178.  
  179. (defun wt-character-loc (loc)
  180.   (cond ((and (consp loc)
  181.               (eq (car loc) 'var)
  182.               (eq (var-kind (cadr loc)) 'CHARACTER))
  183.          (wt "V" (var-loc (cadr loc))))
  184.         ((and (consp loc) (eq (car loc) 'INLINE-CHARACTER))
  185.          (wt-inline-loc (caddr loc) (cadddr loc)))
  186.         ((and (consp loc) (eq (car loc) 'CHARACTER-VALUE))
  187.          (wt (caddr loc)))
  188.         (t (wt "char_code(" loc ")"))))
  189.  
  190. (defun character-loc-p (loc)
  191.   (and (consp loc)
  192.        (or (and (eq (car loc) 'var)
  193.                 (eq (var-kind (cadr loc)) 'CHARACTER))
  194.            (eq (car loc) 'INLINE-CHARACTER)
  195.            (eq (car loc) 'character-value))))
  196.  
  197. (defun wt-character-value (vv character-code)
  198.        (declare (ignore character-code))
  199.        (wt "VV[" vv "]"))
  200.  
  201. (defun wt-long-float-loc (loc)
  202.   (cond ((and (consp loc)
  203.               (eq (car loc) 'var)
  204.               (eq (var-kind (cadr loc)) 'LONG-FLOAT))
  205.          (wt "V" (var-loc (cadr loc))))
  206.         ((and (consp loc) (eq (car loc) 'INLINE-LONG-FLOAT))
  207.          (wt-inline-loc (caddr loc) (cadddr loc)))
  208.         ((and (consp loc) (eq (car loc) 'long-float-value))
  209.          (wt (caddr loc)))
  210.         (t (wt "lf(" loc ")"))))
  211.  
  212. (defun long-float-loc-p (loc)
  213.   (and (consp loc)
  214.        (or (and (eq (car loc) 'var)
  215.                 (eq (var-kind (cadr loc)) 'LONG-FLOAT))
  216.            (eq (car loc) 'INLINE-LONG-FLOAT)
  217.            (eq (car loc) 'long-float-value))))
  218.  
  219. (defun wt-long-float-value (vv long-float-value)
  220.        (declare (ignore long-float-value))
  221.        (wt "VV[" vv "]"))
  222.  
  223. (defun wt-short-float-loc (loc)
  224.   (cond ((and (consp loc)
  225.               (eq (car loc) 'var)
  226.               (eq (var-kind (cadr loc)) 'SHORT-FLOAT))
  227.          (wt "V" (var-loc (cadr loc))))
  228.         ((and (consp loc) (eq (car loc) 'INLINE-SHORT-FLOAT))
  229.          (wt-inline-loc (caddr loc) (cadddr loc)))
  230.         ((and (consp loc) (eq (car loc) 'short-float-value))
  231.          (wt (caddr loc)))
  232.         (t (wt "sf(" loc ")"))))
  233.  
  234. (defun short-float-loc-p (loc)
  235.   (and (consp loc)
  236.        (or (and (eq (car loc) 'var)
  237.                 (eq (var-kind (cadr loc)) 'SHORT-FLOAT))
  238.            (eq (car loc) 'INLINE-SHORT-FLOAT)
  239.            (eq (car loc) 'short-float-value))))
  240.  
  241. (defun wt-short-float-value (vv short-float-value)
  242.        (declare (ignore short-float-value))
  243.        (wt "VV[" vv "]"))
  244.  
  245.